home *** CD-ROM | disk | FTP | other *** search
/ The Atari Compendium / The Atari Compendium (Toad Computers) (1994).iso / files / prgtools / langs / xlisp2.1 / xldist02.zoo / sources / xllist.c < prev    next >
Encoding:
C/C++ Source or Header  |  1990-11-09  |  19.5 KB  |  1,028 lines
  1. /* xllist.c - xlisp built-in list functions */
  2. /*        Copyright (c) 1985, by David Michael Betz
  3.         All Rights Reserved
  4.         Permission is granted for unrestricted non-commercial use        */
  5.  
  6. #include "xlisp.h"
  7.  
  8. /* forward declarations */
  9. #ifdef ANSI
  10. LVAL cxr(char *adstr);
  11. LVAL nth(int charflag);
  12. LVAL assoc(LVAL expr, LVAL alist, LVAL fcn, int tresult);
  13. LVAL subst(LVAL to, LVAL from, LVAL expr, LVAL fcn, int tresult);
  14. LVAL sublis(LVAL alist, LVAL expr, LVAL fcn, int tresult);
  15. LVAL map(int carflag, int valflag);
  16. void splitlist(LVAL pivot,LVAL list, LVAL *psmaller, LVAL *plarger, LVAL fcn);
  17. #ifndef COMMONLISP
  18. int dotest1(LVAL arg, LVAL fun);
  19. #endif
  20. #else
  21. FORWARD LVAL cxr();
  22. FORWARD LVAL nth(),assoc();
  23. FORWARD LVAL subst(),sublis(),map();
  24. FORWARD VOID splitlist();
  25. #endif
  26.  
  27. /* xcar - take the car of a cons cell */
  28. LVAL xcar()
  29. {
  30.     LVAL list;
  31.     list = xlgalist();
  32.     xllastarg();
  33.     return (list ? car(list) : NIL);
  34. }
  35.  
  36. /* xcdr - take the cdr of a cons cell */
  37. LVAL xcdr()
  38. {
  39.     LVAL list;
  40.     list = xlgalist();
  41.     xllastarg();
  42.     return (list ? cdr(list) : NIL);
  43. }
  44.  
  45. /* cxxr functions */
  46. LVAL xcaar() { return (cxr("aa")); }
  47. LVAL xcadr() { return (cxr("da")); }
  48. LVAL xcdar() { return (cxr("ad")); }
  49. LVAL xcddr() { return (cxr("dd")); }
  50.  
  51. /* cxxxr functions */
  52. LVAL xcaaar() { return (cxr("aaa")); }
  53. LVAL xcaadr() { return (cxr("daa")); }
  54. LVAL xcadar() { return (cxr("ada")); }
  55. LVAL xcaddr() { return (cxr("dda")); }
  56. LVAL xcdaar() { return (cxr("aad")); }
  57. LVAL xcdadr() { return (cxr("dad")); }
  58. LVAL xcddar() { return (cxr("add")); }
  59. LVAL xcdddr() { return (cxr("ddd")); }
  60.  
  61. /* cxxxxr functions */
  62. LVAL xcaaaar() { return (cxr("aaaa")); }
  63. LVAL xcaaadr() { return (cxr("daaa")); }
  64. LVAL xcaadar() { return (cxr("adaa")); }
  65. LVAL xcaaddr() { return (cxr("ddaa")); }
  66. LVAL xcadaar() { return (cxr("aada")); }
  67. LVAL xcadadr() { return (cxr("dada")); }
  68. LVAL xcaddar() { return (cxr("adda")); }
  69. LVAL xcadddr() { return (cxr("ddda")); }
  70. LVAL xcdaaar() { return (cxr("aaad")); }
  71. LVAL xcdaadr() { return (cxr("daad")); }
  72. LVAL xcdadar() { return (cxr("adad")); }
  73. LVAL xcdaddr() { return (cxr("ddad")); }
  74. LVAL xcddaar() { return (cxr("aadd")); }
  75. LVAL xcddadr() { return (cxr("dadd")); }
  76. LVAL xcdddar() { return (cxr("addd")); }
  77. LVAL xcddddr() { return (cxr("dddd")); }
  78.  
  79. /* cxr - common car/cdr routine */
  80. LOCAL LVAL cxr(adstr)
  81.   char *adstr;
  82. {
  83.     LVAL list;
  84.  
  85.     /* get the list */
  86.     list = xlgalist();
  87.         
  88.     xllastarg();
  89.  
  90.     /* perform the car/cdr operations */
  91.     while (*adstr && consp(list))
  92.         list = (*adstr++ == 'a' ? car(list) : cdr(list));
  93.  
  94.     /* make sure the operation succeeded */
  95.     if (*adstr && list)
  96.         xlfail("bad argument");
  97.  
  98.     /* return the result */
  99.     return (list);
  100. }
  101.  
  102. /* xcons - construct a new list cell */
  103. LVAL xcons()
  104. {
  105.     LVAL arg1,arg2;
  106.  
  107.     /* get the two arguments */
  108.     arg1 = xlgetarg();
  109.     arg2 = xlgetarg();
  110.     xllastarg();
  111.  
  112.     /* construct a new list element */
  113.     return (cons(arg1,arg2));
  114. }
  115.  
  116. /* xlist - built a list of the arguments */
  117. LVAL xlist()
  118. {
  119.     LVAL last,next,val;
  120.  
  121.     /* protect some pointers */
  122.     xlsave1(val);
  123.  
  124.     /* add each argument to the list */
  125. #if 0    /* old code */
  126.     for (val = NIL; moreargs(); ) {
  127.  
  128.         /* append this argument to the end of the list */
  129.         next = consa(nextarg());
  130.         if (val) rplacd(last,next);
  131.         else val = next;
  132.         last = next;
  133.     }
  134. #else /* new code with tighter inner loop TAA mod */
  135.     if (moreargs()) {
  136.         last = val = consa(nextarg());
  137.         while (moreargs()) {
  138.             next = consa(nextarg());
  139.             rplacd(last,next);
  140.             last = next;
  141.         }
  142.     }
  143. #endif
  144.     /* restore the stack */
  145.     xlpop();
  146.  
  147.     /* return the list */
  148.     return (val);
  149. }
  150.  
  151. /* xappend - built-in function append */
  152. LVAL xappend()
  153. {
  154.     LVAL list,last,next,val;
  155.  
  156.     /* protect some pointers */
  157.     xlsave1(val);
  158.  
  159.     /* append each argument */
  160.     if (moreargs()) {
  161.         while (xlargc > 1) {
  162.  
  163.             /* append each element of this list to the result list */
  164.             for (list = nextarg(); consp(list); list = cdr(list)) {
  165.                 next = consa(car(list));
  166.                 if (val) rplacd(last,next);
  167.                 else val = next;
  168.                 last = next;
  169.             }
  170.             if (list != NIL) xlbadtype(*--xlargv);    /*TAA added errormessage*/
  171.         }
  172.  
  173.         /* handle the last argument */
  174.         if (val) rplacd(last,nextarg());
  175.         else val = nextarg();
  176.     }
  177.  
  178.     /* restore the stack */
  179.     xlpop();
  180.  
  181.     /* return the list */
  182.     return (val);
  183. }
  184.  
  185.  
  186. #ifndef COMMONLISP
  187.  
  188. /* xreverse - built-in function reverse */
  189. LVAL xreverse()
  190. {
  191.     LVAL list,val;
  192.  
  193.     /* protect some pointers */
  194.     xlsave1(val);
  195.  
  196.     /* get the list to reverse */
  197.     list = xlgalist();
  198.     xllastarg();
  199.  
  200.     /* append each element to the head of the result list */
  201.     for (val = NIL; consp(list); list = cdr(list))
  202.         val = cons(car(list),val);
  203.  
  204.     /* restore the stack */
  205.     xlpop();
  206.  
  207.     /* return the list */
  208.     return (val);
  209. }
  210.  
  211. #endif
  212.  
  213. /* xlast - return the last cons of a list */
  214. LVAL xlast()
  215. {
  216.     LVAL list;
  217.  
  218.     /* get the list */
  219.     list = xlgalist();
  220.     xllastarg();
  221.  
  222.     /* find the last cons */
  223.     if (consp(list))            /* TAA fix */
  224.         while (consp(cdr(list))) list = cdr(list);
  225.  
  226.     /* return the last element */
  227.     return (list);
  228. }
  229.  
  230. /* xmember - built-in function 'member' */
  231. LVAL xmember()
  232. {
  233.     LVAL x,list,fcn,val;
  234.     int tresult;
  235.  
  236.     /* protect some pointers */
  237.     xlsave1(fcn);
  238.  
  239.     /* get the expression to look for and the list */
  240.     x = xlgetarg();
  241.     list = xlgalist();
  242.     xltest(&fcn,&tresult);
  243.  
  244.     /* look for the expression */
  245.     for (val = NIL; consp(list); list = cdr(list))
  246.         if (dotest2(x,car(list),fcn) == tresult) {
  247.             val = list;
  248.             break;
  249.         }
  250.  
  251.     /* restore the stack */
  252.     xlpop();
  253.  
  254.     /* return the result */
  255.     return (val);
  256. }
  257.  
  258. /* xassoc - built-in function 'assoc' */
  259. LVAL xassoc()
  260. {
  261.     LVAL x,alist,fcn,pair,val;
  262.     int tresult;
  263.  
  264.     /* protect some pointers */
  265.     xlsave1(fcn);
  266.  
  267.     /* get the expression to look for and the association list */
  268.     x = xlgetarg();
  269.     alist = xlgalist();
  270.     xltest(&fcn,&tresult);
  271.  
  272.     /* look for the expression */
  273.     for (val = NIL; consp(alist); alist = cdr(alist))
  274.         if (((pair = car(alist)) != 0) && consp(pair))
  275.             if (dotest2(x,car(pair),fcn) == tresult) {
  276.                 val = pair;
  277.                 break;
  278.             }
  279.  
  280.     /* restore the stack */
  281.     xlpop();
  282.  
  283.     /* return result */
  284.     return (val);
  285. }
  286.  
  287. /* xsubst - substitute one expression for another */
  288. LVAL xsubst()
  289. {
  290.     LVAL to,from,expr,fcn,val;
  291.     int tresult;
  292.  
  293.     /* protect some pointers */
  294.     xlsave1(fcn);
  295.  
  296.     /* get the to value, the from value and the expression */
  297.     to = xlgetarg();
  298.     from = xlgetarg();
  299.     expr = xlgetarg();
  300.     xltest(&fcn,&tresult);
  301.  
  302.     /* do the substitution */
  303.     val = subst(to,from,expr,fcn,tresult);
  304.  
  305.     /* restore the stack */
  306.     xlpop();
  307.  
  308.     /* return the result */
  309.     return (val);
  310. }
  311.  
  312. /* subst - substitute one expression for another */
  313. LOCAL LVAL subst(to,from,expr,fcn,tresult)
  314.   LVAL to,from,expr,fcn; int tresult;
  315. {
  316.     LVAL carval,cdrval;
  317.  
  318.     if (dotest2(expr,from,fcn) == tresult)
  319.         return (to);
  320.     else if (consp(expr)) {
  321.         xlsave1(carval);
  322.         carval = subst(to,from,car(expr),fcn,tresult);
  323.         cdrval = subst(to,from,cdr(expr),fcn,tresult);
  324.         xlpop();
  325.  
  326. /* the following TAA mod makes subst like COMMON LISP */
  327.         
  328.         if ((carval == car(expr)) && (cdrval == cdr(expr)))
  329.             return expr; /* no change */
  330.         else
  331.             return (cons(carval,cdrval));
  332.     }
  333.     else
  334.         return (expr);
  335. }
  336.  
  337. /* xsublis - substitute using an association list */
  338. LVAL xsublis()
  339. {
  340.     LVAL alist,expr,fcn,val;
  341.     int tresult;
  342.  
  343.     /* protect some pointers */
  344.     xlsave1(fcn);
  345.  
  346.     /* get the assocation list and the expression */
  347.     alist = xlgalist();
  348.     expr = xlgetarg();
  349.     xltest(&fcn,&tresult);
  350.  
  351.     /* do the substitution */
  352.     val = sublis(alist,expr,fcn,tresult);
  353.  
  354.     /* restore the stack */
  355.     xlpop();
  356.  
  357.     /* return the result */
  358.     return (val);
  359. }
  360.  
  361. /* sublis - substitute using an association list */
  362. LOCAL LVAL sublis(alist,expr,fcn,tresult)
  363.   LVAL alist,expr,fcn; int tresult;
  364. {
  365.     LVAL carval,cdrval,pair;
  366.  
  367.     if ((pair = assoc(expr,alist,fcn,tresult)) != 0)
  368.         return (cdr(pair));
  369.     else if (consp(expr)) {
  370.         xlsave1(carval);
  371.         carval = sublis(alist,car(expr),fcn,tresult);
  372.         cdrval = sublis(alist,cdr(expr),fcn,tresult);
  373.         xlpop();
  374. /* TAA MOD for making like common lisp */
  375.         if ((car(expr) == carval) && (cdr(expr) == cdrval))
  376.             return (expr);
  377.         else
  378.             return (cons(carval,cdrval));
  379.     }
  380.     else
  381.         return (expr);
  382. }
  383.  
  384. /* assoc - find a pair in an association list */
  385. LOCAL LVAL assoc(expr,alist,fcn,tresult)
  386.   LVAL expr,alist,fcn; int tresult;
  387. {
  388.     LVAL pair;
  389.  
  390.     for (; consp(alist); alist = cdr(alist))
  391.         if (((pair = car(alist)) != 0) && consp(pair))
  392.             if (dotest2(expr,car(pair),fcn) == tresult)
  393.                 return (pair);
  394.     return (NIL);
  395. }
  396.  
  397. #ifndef COMMONLISP
  398. /* xremove - built-in function 'remove' */
  399. LVAL xremove()
  400. {
  401.     LVAL x,list,fcn,val,last,next;
  402.     int tresult;
  403.  
  404.     /* protect some pointers */
  405.     xlstkcheck(2);
  406.     xlsave(fcn);
  407.     xlsave(val);
  408.  
  409.     /* get the expression to remove and the list */
  410.     x = xlgetarg();
  411.     list = xlgalist();
  412.     xltest(&fcn,&tresult);
  413.  
  414.     /* remove matches */
  415.     for (; consp(list); list = cdr(list))
  416.  
  417.         /* check to see if this element should be deleted */
  418.         if (dotest2(x,car(list),fcn) != tresult) {
  419.             next = consa(car(list));
  420.             if (val) rplacd(last,next);
  421.             else val = next;
  422.             last = next;
  423.         }
  424.  
  425.     /* restore the stack */
  426.     xlpopn(2);
  427.  
  428.     /* return the updated list */
  429.     return (val);
  430. }
  431.  
  432. #ifdef ADDEDTAA
  433. /* xcountif - built-in function 'count-if      TAA MOD addition */
  434. LVAL xcountif()
  435. {
  436.     int counter=0;
  437.     LVAL list, fcn;
  438.  
  439.     xlsave1(fcn);
  440.         
  441.     /* get the arguments */
  442.     fcn = xlgetarg();
  443.     list = xlgalist();
  444.     xllastarg();
  445.  
  446.     /* examine arg and count */
  447.     for (; consp(list); list = cdr(list))
  448.         if (dotest1(car(list),fcn)) counter++;
  449.  
  450.     xlpop();
  451.  
  452.     return (cvfixnum(counter));
  453. }
  454.  
  455. /* xfindif - built-in function 'find-if'    TAA MOD */
  456. LVAL xfindif()
  457. {
  458.     LVAL list, fcn;
  459.  
  460.     xlsave1(fcn);
  461.  
  462.     fcn = xlgetarg();
  463.     list = xlgalist();
  464.     xllastarg();
  465.  
  466.     for (; consp(list); list = cdr(list))
  467.         if (dotest1(car(list), fcn)) {
  468.             xlpop();
  469.             return (car(list));
  470.         };
  471.  
  472.     xlpop();
  473.     return (NIL);
  474. }
  475. #endif
  476.  
  477. /* remif - common code for 'remove-if' and 'remove-if-not' */
  478. #ifdef ANSI
  479. static LVAL remif(int tresult)
  480. #else
  481. LOCAL LVAL remif(tresult)
  482.   int tresult;
  483. #endif
  484. {
  485.     LVAL list,fcn,val,last,next;
  486.  
  487.     /* protect some pointers */
  488.     xlstkcheck(2);
  489.     xlsave(fcn);
  490.     xlsave(val);
  491.  
  492.     /* get the expression to remove and the list */
  493.     fcn = xlgetarg();
  494.     list = xlgalist();
  495.     xllastarg();
  496.  
  497.     /* remove matches */
  498.     for (; consp(list); list = cdr(list))
  499.  
  500.         /* check to see if this element should be deleted */
  501.         if (dotest1(car(list),fcn) != tresult) {
  502.             next = consa(car(list));
  503.             if (val) rplacd(last,next);
  504.             else val = next;
  505.             last = next;
  506.         }
  507.  
  508.     /* restore the stack */
  509.     xlpopn(2);
  510.  
  511.     /* return the updated list */
  512.     return (val);
  513. }
  514.  
  515. /* xremif - built-in function 'remove-if' */
  516. LVAL xremif()
  517. {
  518.     return (remif(TRUE));
  519. }
  520.  
  521. /* xremifnot - built-in function 'remove-if-not' */
  522. LVAL xremifnot()
  523. {
  524.     return (remif(FALSE));
  525. }
  526. #endif
  527.  
  528. #ifndef COMMONLISP
  529. /* dotest1 - call a test function with one argument */
  530. LOCAL int dotest1(arg,fun)
  531.   LVAL arg,fun;
  532. {
  533.     LVAL *newfp;
  534.  
  535.     /* create the new call frame */
  536.     newfp = xlsp;
  537.     pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
  538.     pusharg(fun);
  539.     pusharg(cvfixnum((FIXTYPE)1));
  540.     pusharg(arg);
  541.     xlfp = newfp;
  542.  
  543.     /* return the result of applying the test function */
  544.     return (xlapply(1) != NIL);
  545.  
  546. }
  547. #endif
  548.  
  549. /* dotest2 - call a test function with two arguments */
  550. int dotest2(arg1,arg2,fun)
  551.   LVAL arg1,arg2,fun;
  552. {
  553.     LVAL *newfp;
  554.  
  555.     /* create the new call frame */
  556.     newfp = xlsp;
  557.     pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
  558.     pusharg(fun);
  559.     pusharg(cvfixnum((FIXTYPE)2));
  560.     pusharg(arg1);
  561.     pusharg(arg2);
  562.     xlfp = newfp;
  563.  
  564.     /* return the result of applying the test function */
  565.     return (xlapply(2) != NIL);
  566.  
  567. }
  568.  
  569. /* xnth - return the nth element of a list */
  570. LVAL xnth()
  571. {
  572.     return (nth(TRUE));
  573. }
  574.  
  575. /* xnthcdr - return the nth cdr of a list */
  576. LVAL xnthcdr()
  577. {
  578.     return (nth(FALSE));
  579. }
  580.  
  581. /* nth - internal nth function */
  582. LOCAL LVAL nth(carflag)
  583.   int carflag;
  584. {
  585.     LVAL list,num;
  586.     FIXTYPE n;
  587.  
  588.     /* get n and the list */
  589.     num = xlgafixnum();
  590. /*  list = xlgacons(); */
  591.     list = xlgalist();        /* TAA fix */
  592.         
  593.     xllastarg();
  594.  
  595.     /* make sure the number isn't negative */
  596.     if ((n = getfixnum(num)) < 0)
  597.         xlfail("bad argument");
  598.  
  599.     /* find the nth element */
  600.     while (consp(list) && --n >= 0)
  601.         list = cdr(list);
  602.  
  603.     /* return the list beginning at the nth element */
  604.     return (carflag && consp(list) ? car(list) : list);
  605. }
  606.  
  607. /* xlength - return the length of a list or string */
  608. LVAL xlength()
  609. {
  610.     FIXTYPE n;
  611.     LVAL arg;
  612.  
  613.     /* get the list or string */
  614.     arg = xlgetarg();
  615.     xllastarg();
  616.  
  617.     /* find the length of a list */
  618.     if (listp(arg))
  619.         for (n = 0; consp(arg); n++)
  620.             arg = cdr(arg);
  621.  
  622.     /* find the length of a string */
  623.     else if (stringp(arg))
  624.         n = (FIXTYPE)getslength(arg)-1;
  625.  
  626.     /* find the length of a vector */
  627.     else if (vectorp(arg))
  628.         n = (FIXTYPE)getsize(arg);
  629.  
  630.     /* otherwise, bad argument type */
  631.     else
  632.                 xlbadtype(arg);
  633.  
  634.     /* return the length */
  635.     return (cvfixnum(n));
  636. }
  637.  
  638. /* xmapc - built-in function 'mapc' */
  639. LVAL xmapc()
  640. {
  641.     return (map(TRUE,FALSE));
  642. }
  643.  
  644. /* xmapcar - built-in function 'mapcar' */
  645. LVAL xmapcar()
  646. {
  647.     return (map(TRUE,TRUE));
  648. }
  649.  
  650. /* xmapl - built-in function 'mapl' */
  651. LVAL xmapl()
  652. {
  653.     return (map(FALSE,FALSE));
  654. }
  655.  
  656. /* xmaplist - built-in function 'maplist' */
  657. LVAL xmaplist()
  658. {
  659.     return (map(FALSE,TRUE));
  660. }
  661.  
  662. /* map - internal mapping function */
  663. LOCAL LVAL map(carflag,valflag)
  664.   int carflag,valflag;
  665. {
  666.     LVAL *newfp,fun,lists,val,last,p,x,y;
  667.     int argc;
  668.  
  669.     /* protect some pointers */
  670.     xlstkcheck(3);
  671.     xlsave(fun);
  672.     xlsave(lists);
  673.     xlsave(val);
  674.  
  675.     /* get the function to apply and the first list */
  676.     fun = xlgetarg();
  677.     lists = xlgalist();
  678.  
  679.     /* initialize the result list */
  680.     val = (valflag ? NIL : lists);
  681.  
  682.     /* build a list of argument lists */
  683.     for (lists = last = consa(lists); moreargs(); last = cdr(last))
  684.         rplacd(last,cons(xlgalist(),NIL));
  685.  
  686.     /* loop through each of the argument lists */
  687.     for (;;) {
  688.  
  689.         /* build an argument list from the sublists */
  690.         newfp = xlsp;
  691.         pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
  692.         pusharg(fun);
  693.         pusharg(NIL);
  694.         argc = 0;
  695.         for (x = lists; x && ((y = car(x)) != 0) && consp(y); x = cdr(x)) {
  696.             pusharg(carflag ? car(y) : y);
  697.             rplaca(x,cdr(y));
  698.             ++argc;
  699.         }
  700.  
  701.         /* quit if any of the lists were empty */
  702.         if (x) {
  703.             xlsp = newfp;
  704.             break;
  705.         }
  706.  
  707.         /* apply the function to the arguments */
  708.         newfp[2] = cvfixnum((FIXTYPE)argc);
  709.         xlfp = newfp;
  710.         if (valflag) {
  711.             p = consa(xlapply(argc));
  712.             if (val) rplacd(last,p);
  713.             else val = p;
  714.             last = p;
  715.         }
  716.         else
  717.             xlapply(argc);
  718.     }
  719.  
  720.     /* restore the stack */
  721.     xlpopn(3);
  722.  
  723.     /* return the last test expression value */
  724.     return (val);
  725. }
  726.  
  727. /* xrplca - replace the car of a list node */
  728. LVAL xrplca()
  729. {
  730.     LVAL list,newcar;
  731.  
  732.     /* get the list and the new car */
  733.     list = xlgacons();
  734.     newcar = xlgetarg();
  735.     xllastarg();
  736.  
  737.     /* replace the car */
  738.     rplaca(list,newcar);
  739.  
  740.     /* return the list node that was modified */
  741.     return (list);
  742. }
  743.  
  744. /* xrplcd - replace the cdr of a list node */
  745. LVAL xrplcd()
  746. {
  747.     LVAL list,newcdr;
  748.  
  749.     /* get the list and the new cdr */
  750.     list = xlgacons();
  751.     newcdr = xlgetarg();
  752.     xllastarg();
  753.  
  754.     /* replace the cdr */
  755.     rplacd(list,newcdr);
  756.  
  757.     /* return the list node that was modified */
  758.     return (list);
  759. }
  760.  
  761. /* xnconc - destructively append lists */
  762. LVAL xnconc()
  763. {
  764.     LVAL next,last,val;
  765.  
  766.     /* initialize */
  767.     val = NIL;
  768.     
  769.     /* concatenate each argument */
  770.     if (moreargs()) {
  771.         while (xlargc > 1) {
  772.  
  773.             /* TAA mod -- give error message if not a list */
  774.             if (((next = nextarg()) != NIL) && consp(next)) {
  775.  
  776.                 /* concatenate this list to the result list */
  777.                 if (val) rplacd(last,next);
  778.                 else val = next;
  779.  
  780.                 /* find the end of the list */
  781.                 while (consp(cdr(next)))
  782.                     next = cdr(next);
  783.                 last = next;
  784.             }
  785.             else if (next != NIL) xlbadtype(*--xlargv); /* TAA -- oops! */
  786.         }
  787.  
  788.         /* handle the last argument */
  789.         if (val) rplacd(last,nextarg());
  790.         else val = nextarg();
  791.     }
  792.  
  793.     /* return the list */
  794.     return (val);
  795. }
  796. #ifndef COMMONLISP
  797. /* xdelete - built-in function 'delete' */
  798. LVAL xdelete()
  799. {
  800.     LVAL x,list,fcn,last,val;
  801.     int tresult;
  802.  
  803.     /* protect some pointers */
  804.     xlsave1(fcn);
  805.  
  806.     /* get the expression to delete and the list */
  807.     x = xlgetarg();
  808.     list = xlgalist();
  809.     xltest(&fcn,&tresult);
  810.  
  811.     /* delete leading matches */
  812.     while (consp(list)) {
  813.         if (dotest2(x,car(list),fcn) != tresult)
  814.             break;
  815.         list = cdr(list);
  816.     }
  817.     val = last = list;
  818.  
  819.     /* delete embedded matches */
  820.     if (consp(list)) {
  821.  
  822.         /* skip the first non-matching element */
  823.         list = cdr(list);
  824.  
  825.         /* look for embedded matches */
  826.         while (consp(list)) {
  827.  
  828.             /* check to see if this element should be deleted */
  829.             if (dotest2(x,car(list),fcn) == tresult)
  830.                 rplacd(last,cdr(list));
  831.             else
  832.                 last = list;
  833.  
  834.             /* move to the next element */
  835.             list = cdr(list);
  836.         }
  837.     }
  838.  
  839.     /* restore the stack */
  840.     xlpop();
  841.  
  842.     /* return the updated list */
  843.     return (val);
  844. }
  845.  
  846. /* delif - common routine for 'delete-if' and 'delete-if-not' */
  847. #ifdef ANSI
  848. static LVAL delif(int tresult)
  849. #else
  850. LOCAL LVAL delif(tresult)
  851.   int tresult;
  852. #endif
  853. {
  854.     LVAL list,fcn,last,val;
  855.  
  856.     /* protect some pointers */
  857.     xlsave1(fcn);
  858.  
  859.     /* get the expression to delete and the list */
  860.     fcn = xlgetarg();
  861.     list = xlgalist();
  862.     xllastarg();
  863.  
  864.     /* delete leading matches */
  865.     while (consp(list)) {
  866.         if (dotest1(car(list),fcn) != tresult)
  867.             break;
  868.         list = cdr(list);
  869.     }
  870.     val = last = list;
  871.  
  872.     /* delete embedded matches */
  873.     if (consp(list)) {
  874.  
  875.         /* skip the first non-matching element */
  876.         list = cdr(list);
  877.  
  878.         /* look for embedded matches */
  879.         while (consp(list)) {
  880.  
  881.             /* check to see if this element should be deleted */
  882.             if (dotest1(car(list),fcn) == tresult)
  883.                 rplacd(last,cdr(list));
  884.             else
  885.                 last = list;
  886.  
  887.             /* move to the next element */
  888.             list = cdr(list);
  889.         }
  890.     }
  891.  
  892.     /* restore the stack */
  893.     xlpop();
  894.  
  895.     /* return the updated list */
  896.     return (val);
  897. }
  898.  
  899. /* xdelif - built-in function 'delete-if' */
  900. LVAL xdelif()
  901. {
  902.     return (delif(TRUE));
  903. }
  904.  
  905. /* xdelifnot - built-in function 'delete-if-not' */
  906. LVAL xdelifnot()
  907. {
  908.     return (delif(FALSE));
  909. }
  910. #endif
  911.  
  912.  
  913. /*
  914.     This sorting algorithm is based on a Modula-2 sort written by
  915.     Richie Bielak and published in the February 1988 issue of
  916.     "Computer Language" magazine in a letter to the editor.
  917. */
  918.  
  919.  
  920. /* gluelists - glue the smaller and larger lists with the pivot */
  921. #ifdef ANSI
  922. static LVAL gluelists(LVAL smaller, LVAL pivot, LVAL larger)
  923. #else
  924. LOCAL LVAL gluelists(smaller,pivot,larger)
  925.   LVAL smaller,pivot,larger;
  926. #endif
  927. {
  928.     LVAL last;
  929.     
  930.     /* larger always goes after the pivot */
  931.     rplacd(pivot,larger);
  932.  
  933.     /* if the smaller list is empty, we're done */
  934.     if (null(smaller))
  935.         return (pivot);
  936.  
  937.     /* append the smaller to the front of the resulting list */
  938.     for (last = smaller; consp(cdr(last)); last = cdr(last))
  939.         ;
  940.     rplacd(last,pivot);
  941.     return (smaller);
  942. }
  943.  
  944. /* sortlist - sort a list using quicksort */
  945. #ifdef ANSI
  946. static LVAL sortlist(LVAL list, LVAL fcn)
  947. #else
  948. LOCAL LVAL sortlist(list,fcn)
  949.   LVAL list,fcn;
  950. #endif
  951. {
  952.     LVAL smaller,pivot,larger;
  953.     
  954.     /* protect some pointers */
  955.     xlstkcheck(3)
  956.     xlsave(smaller);
  957.     xlsave(pivot);
  958.     xlsave(larger);
  959.     
  960.     /* lists with zero or one element are already sorted */
  961.     if (consp(list) && consp(cdr(list))) {
  962.         pivot = list; list = cdr(list);
  963.         splitlist(pivot,list,&smaller,&larger,fcn);
  964.         smaller = sortlist(smaller,fcn);
  965.         larger = sortlist(larger,fcn);
  966.         list = gluelists(smaller,pivot,larger);
  967.     }
  968.  
  969.     /* cleanup the stack and return the sorted list */
  970.     xlpopn(3);
  971.     return (list);
  972. }
  973.  
  974. /* splitlist - split the list around the pivot */
  975. LOCAL VOID splitlist(pivot,list,psmaller,plarger,fcn)
  976.   LVAL pivot,list,*psmaller,*plarger,fcn;
  977. {
  978.     LVAL next;
  979.     
  980.     /* initialize the result lists */
  981.     *psmaller = *plarger = NIL;
  982.     
  983.     /* In case of garbage collection TAA Mod thanx to Neal Holtz */
  984.     xlstkcheck(2);
  985.     xlprotect(list);
  986.     xlsave(next);
  987.  
  988.     /* split the list */
  989.     for (; consp(list); list = next) {
  990.         next = cdr(list);
  991.         if (dotest2(car(list),car(pivot),fcn)) {
  992.             rplacd(list,*psmaller);
  993.             *psmaller = list;
  994.         }
  995.         else {
  996.             rplacd(list,*plarger);
  997.             *plarger = list;
  998.         }
  999.     }
  1000.  
  1001.     /* restore the stack */
  1002.     xlpopn(2);
  1003. }
  1004.  
  1005. /* xsort - built-in function 'sort' */
  1006. LVAL xsort()
  1007. {
  1008.     LVAL list,fcn;
  1009.  
  1010.     /* protect some pointers */
  1011.     xlstkcheck(2);
  1012.     xlsave(list);
  1013.     xlsave(fcn);
  1014.  
  1015.     /* get the list to sort and the comparison function */
  1016.     list = xlgalist();
  1017.     fcn = xlgetarg();
  1018.     xllastarg();
  1019.  
  1020.     /* sort the list */
  1021.     list = sortlist(list,fcn);
  1022.  
  1023.     /* restore the stack and return the sorted list */
  1024.     xlpopn(2);
  1025.     return (list);
  1026. }
  1027.  
  1028.